perm filename SCMSS.F4[NEW,LCS]20 blob
sn#418042 filedate 1979-02-13 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00003 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 C****** SCMSS *********** 12/1/75
C00024 00003 2114 FORMAT(72A1)
C00030 ENDMK
C⊗;
C****** SCMSS *********** 12/1/75
SUBROUTINE SCMSS
COMMON /PLTR/PLT,RHT,DIS/PTR/KWDS(1)
1 /MKX/KSLA,ISM,LESS,IGT,NNO(5),MINUS
COMMON/RINP/R(10,85),RPOS(2,50) /RMOD/RMODE2,SET4,IBEAM,NOSET,
1 STEM,STUP,NTC,PS2,RAM,RDD,ITB,POSB /JCHAR/IXX,ISEMI,IBLA
1 /A2Z/LAA,LBB,A1(4),LGG,A2(6),LNN,LOH,A3(3),LSS,LTT,A4(4),LYY
1 /NUM/NUM(9),N9
COMMON R2,JA,G,H,R3,U(39)/SCM/V(78),I,LCNT,STAFF,JLIST(200),REND
C JLIST WILL SOMETIMES BE USED(WIPED OUT) FOR R(X,Y) OVERFLOW(>50 ITEMS.)
DIMENSION RLIST(200),NOMOR(6),WARN(6),ISV(5)
C /SCX/ ALSO IN WORDS, NEWR
COMMON/SCX/JALPHA(30),RB,RC,JZ,IRHY,JD,KA,KB,IZ
1/STF/RSTFAC(8),RSTJ2 /LIMIT/LIMIT,ITEM,LL,IS,IX
1 /FRMT/F78F(1),FA1(1),FA5(1),IREAD /IDEV/IDEV
1/XRN/RN(1) /ALF/INP(72),ML /POS/POS1,POS2,PSFB
COMMON /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JN,DBST
1,NFLG,JXX,ISEMX,JG,VX(50),IAMP,K,KN,M,MODE,IBLX
EQUIVALENCE (VX1,VX(1)),(INP1,INP(1)),(VX2,VX(2)),(VX3,VX(3)),
1(VX4,VX(4)),(VX5,VX(5)),(JLIST,RLIST)
1 ,(INP2,INP(2)),(INP3,INP(3)),(INP4,INP(4))
1,(ISTAR,JALPHA(8)),(ICOL,JALPHA(9)),(IRP,JALPHA(6)),
1(ILP,JALPHA(5)),(NEG,JALPHA(2)),(IAT,JALPHA(16)),(IDOT,
1JALPHA(3))
C--THESE ARE IN 'RESTS' NOW. DATA IXX/'X'/,LCNT/1/,ISEMI/';'/,IBLA/' '/
JDEV=IDEV
1177 RB=0
IF(JA.EQ.140)GO TO 77
IF(JA.NE.144)GO TO 11
77 MODE=1
IBEAM=-1
IZ=0
IREAD=0
POS2=0
POS1=0
CC THIS IS SET IN MSX NOW **** RMODE2=R3
IF(JA.NE.144)GO TO 91
REREAD 80052,L,L,L,STAFF,RMODE2
C GET THE FILE NAME FOR 'READ NAME'
CALL LO2UP(L)
IF(LOOK(L)+LOOKD(L))GO TO 101
CALL TYPSTR('FILE NOT FOUND - ')
CALL TYPWRD(L)
CALL TYPCRLF
GO TO 690
101 IREAD=-1
C IREAD=-1 =SOS FILE. =-2 =NO LINE NUMBERS.
REWIND 22
CALL IFILE(22,L)
291 READ(22,21141,END=68),L,INP
IF(L.NE.0)GO TO 491
C JUMP IF LINE NUMBERS
IREAD=-2
C THIS IS FOR NON-'ET' FILES WITH NO LINE NUMBS.
IF(INP1.EQ.LOH)GO TO 391
REREAD 2114,INP
491 RB=0
IF(INP1.EQ.ISTAR)GO TO 191
CALL TYPSTR('STAFF NUM=')
ACCEPT 80052,STAFF
CC REREAD 4177,RA,RB
CC CALL LO2UP(RA)
CALL A2READ(RA,RB)
IF(RA.NE.'SP')GO TO 91
C NOW SPACER CAN BE SET AT THIS POINT
SET4=RB
GO TO 111
191 REREAD 2310,L,SET4,STAFF,POS1,POS2,PSFB
C READS SPACING STAFF NUM, THIS STAFF NUM, AND POSITIONS.
C FIRST CHAR. MUST BE * . !!! ASSUMES NO LINE NUMBERS NOW!!!
IF(POS2.EQ.0)POS2=200
READ(22,2114)INP
CALL LULOOP
C LULOOP CHANGES ALL LOWER CASE TO UPPER IN 'INP' ARRAY.
RB=-1
91 CALL TYPSTR('SPACING STAFF =')
CALL TYPFLT(SET4)
CALL TYPCRLF
GO TO 111
391 READ(22,2114,END=68)INP
C GET RID OF DIRECTORY
IF(INP3.NE.ISEMI)GO TO 391
READ(22,2114,END=68)INP
GO TO 291
11 IF(IREAD)GO TO 2304
RB=0
GO TO 111
467 IDEV=5
GO TO 4333
444 SET4=RA
111 CALL SETUP
IF(STUP.GE.0)GO TO 8
C SKIPS IF USING SETUP ON SOME STAFF
IF(POS2.NE.0)GO TO 4334
C JUMP IF POS1, POS2, ETC. WERE SET UP IN FILE (* SP ST POS1 POS2 X)
4333 IF(IDEV.EQ.5)CALL TYPSTR('TYPE POS1, POS2, (SPC) ')
READ(IDEV,F78F,END=467)POS1,POS2,PSFB
C DON'T USE INVIS. RESTS WITH SPACING FEATURE!!!!
CC REREAD 4177,K,RA
CC CALL LO2UP(K)
CALL A2READ(K,RA)
IF(K.EQ.'SP')GO TO 444
C TYPE "SPn" TO SET SPACING STAFF AT THIS POINT.
IF(K.EQ.IAT)GO TO 467
CATCH '@' WHEN POS1 AND P2 ARE EXPECTED.
IF(K.EQ.LESS)GO TO 467
IF(K.NE.IGT)GO TO 567
IDEV=1
GO TO 4333
567 IF(POS2.EQ.0)POS2=200.
IF(POS1.GE.POS2)GO TO 4333
C TYPE ANY POSITIVE 3RD NUM. FOR PSUEDO-FIBONACCI SPACING OF RHYTH.
4334 STUP=STUP-PSFB
IF(JA.EQ.144)GO TO 2177
8 IF(JA.EQ.144)GO TO 2311
IF(JA)GO TO 691
CALL TYPCRLF
IF(RB.GT.0)GO TO 891
IF(IREAD)GO TO 2304
367 GO TO (1,2,3,4,5,677)MODE
CCC367 GO TO (1,2,3,4,5,69)MODE
GO TO 2177
2304 IF(IREAD.EQ.-1)REREAD 21141,L,INP
IF(IREAD.EQ.-2)REREAD 2114,INP
CALL LULOOP
2303 RB=0
IF(INP1.EQ.ISTAR)GO TO 991
CCC RB=1
CCC GO TO 111
POS2=0
JA=144
GO TO 491
991 REREAD 2310,L,SET4,STAFF,POS1,POS2,PSFB
C READS SPACING STAFF NUM, THIS STAFF NUM, AND POSITIONS.
C FIRST CHAR. MUST BE * . !!! ASSUMES NO LINE NUMBERS NOW!!!
IF(POS2.EQ.0)POS2=200
JA=-1
GO TO 111
691 READ(22,2114)INP
CALL LULOOP
JA=144
RB=-1
2311 IF(IREAD)GO TO 2177
891 CALL TYPSTR('STAFF NUM=')
IF(RB)GO TO 231
IF(STFNUM(STAFF))GO TO 2305
231 CALL TYPFLT(STAFF)
IF(RB.GE.0)GO TO 2177
CALL TYPCRLF
IF(JA.EQ.144)GO TO 2177
GO TO 91
CV CALL TYPSTR('SPACING STAFF =')
CV CALL TYPFLT(SET4)
CV CALL TYPCRLF
C FILE CAN SET STAFF # AND SPACING STAFF # (STn/SPn/)
CC IF(JA.EQ.144)GO TO 2177
CV GO TO 111
167 IDEV=5
GO TO 2311
2305 READ(IDEV,80052,END=167)STAFF
IF(STAFF.NE.444)GO TO 2177
CC REREAD 4177,RA,RB
CC CALL LO2UP(RA)
CALL A2READ(RA,RB)
IF(RA.EQ.LESS)GO TO 167
IF(RA.NE.IGT)GO TO 667
IDEV=1
GO TO 891
667 IF(RA.NE.'SP')GO TO 2177
C NOW SPACER CAN BE SET AT THIS POINT
SET4=RB
GO TO 2303
2310 FORMAT(A1,5F)
2177 IF(IREAD)CALL TYPOUT
IF(STAFF.GE.99)GO TO 690
C TYPE 99 OR 999 TO ESCAPE WHEN IN READ-IN MODE
REND=0
IF(IREAD)GO TO 80041
2301 IF(IREAD.EQ.-2)GO TO 2307
READ(22,21141,END=68),L,INP
IF(L.NE.0)GO TO 2300
C JUMP IF LINE NUMBERS
IF(INP1.EQ.LOH)GO TO 2307
IREAD=-2
C THIS IS FOR NON-'ET' FILES WITH NO LINE NUMBS.
REREAD 2114,INP
GO TO 2300
2307 READ(22,2114,END=68)INP
IF(IREAD.EQ.-2)GO TO 2300
IF(INP3.NE.ISEMI)GO TO 2307
IREAD=-2
READ(22,2114)INP
GO TO 2307
2300 CALL LULOOP
IF(JA.NE.144)GO TO 2308
IF(MODE.EQ.1)GO TO 2303
2308 IF(MODE.EQ.6)GO TO 1111
IF(INP1.EQ.IBLA)GO TO 8006
IF(INP1.EQ.ISEMI)GO TO 8006
C 'ET' FILES MUST HAVE ';' AS 1ST CHAR. BLANK LINES ARE IGNORED!!
CALL TYPOUT
CC IF(IDEV.EQ.5)CALL TYPOUT
GO TO 6177
1111 MODE=1
REND=2
IZ=0
C ABOVE ALLOWS MORE STAVES TO BE READ
2111 IDEV=JDEV
RETURN
CC168 IF(NOSET.EQ.0)RETURN
80052 FORMAT(F,A4,A5,2F)
267 IDEV=5
IF(MODE.EQ.3)CALL NOTNUM
GO TO 2111
CXX GO TO 367
4 IF(IDEV.EQ.5)CALL TYPSTR('ADD BEAMS? ')
330 READ(IDEV,2114,END=677)INP
CC330 READ(IDEV,2114,END=267)INP
CALL LULOOP
IF(INP1.EQ.LGG)GO TO 677
CCC IF(INP1.EQ.'G')GO TO 69
C TYPE 'GO' TO PASS LATER ITEMS
IF(INP1.EQ.N9.AND.INP2.EQ.INP1)GO TO 99
IF(INP1.EQ.LBB)GO TO 99
IF(INP1.EQ.LYY)GO TO 1
C FOR BEAMS? TYPE 'nB' INSTEAD OF 'Y' FOR AUTOMATIC.
IF(INP1.EQ.LNN)GO TO 2000
IF(INP1.EQ.ISEMI)GO TO 2000
IF(INP1.EQ.LESS)GO TO 267
IF(INP1.NE.IGT)GO TO 767
IDEV=1
GO TO(1,2,3,4,5)MODE
767 IF(INP1.NE.IBLA)GO TO 5177
2000 MODE=MODE+1
IF(IDEV.EQ.5)WRITE(21,2114)INP4
GO TO 11
CCC69 IF(IDEV.EQ.1)GO TO 690
CCC END FILE 21
CCC CALL TYPSTR('INPUT SAVED ON FOR21.DAT')
CCC CALL TYPCRLF
690 REND=1
GO TO 2111
CC GO TO 168
3 IF(IDEV.EQ.5)CALL TYPSTR('ADD MARKS? ')
GO TO 330
5 IF(IDEV.EQ.5)CALL TYPSTR('ADD SLURS? ')
GO TO 330
8006 MODE=MODE+1
IF(MODE.NE.2)GO TO 177
CCC IF(RMODE2.EQ.2)GO TO 80041
C FOR NEW INPUT FORMAT -- TYPE 140 2 OR 144 -2 ETC.
177 IF(IREAD)GO TO 2301
IF(MODE.GT.5)GO TO 677
IF(IDEV.EQ.1)GO TO 367
C RETURN ONLY IF IN TTY MODE. (NOT READING A FILE)
GO TO 2111
677 IF(IDEV.EQ.1)GO TO 68
END FILE 21
CALL TYPSTR('INPUT SAVED ON FOR21.DAT')
CALL TYPCRLF
68 REND=-1
GO TO 2111
CC GO TO 168
99 IF(INP3.EQ.N9)GO TO 999
C ELSE GET ANOTHER CHANCE TO SAY 'NO'. 99=BACKUP, 999=ESCAPE
MODE=MODE-1
IF(MODE.EQ.0)GO TO 999
IS=ISV(MODE)
GO TO 11
C INSERT BACKUP ROUTINE
999 REND=99
GO TO 2111
C FIX BACKUPS********
8015 RA=0
DO 15 J=1,I-1
15 RA=RA+4./V(J)
K=IRHY-I+1
CALL TYPSTR('TOTAL RHY=')
CALL TYPFLT(RA)
CALL TYPSTR(' QTRS. ')
CALL TYPINT(K)
CALL TYPSTR(' MORE RHYTHMS NEEDED')
CALL TYPCRLF
IDEV=5
C RETURNS TO TTY MODE IF READING A FILE WITH 'FILE' FEATURE.
IF(IREAD)IREAD=-IREAD
C ↑↑↑↑↑ SO YOU CAN TYPE MORE LINES WHEN ERROR ON READIN.
2 IF(IDEV.EQ.5)CALL TYPSTR('TYPE ')
CALL TYPINT(IRHY)
CALL TYPSTR(' RHYTHMS')
CALL TYPCRLF
1 ISV(MODE)=IS
CALL TYPE
IF(INP1.NE.IAT)GO TO 1001
C '@' STARTS MODE2 INPUT
IF(INP2.NE.IBLA)GO TO 1001
C BUT NOT IF IT'S REALLY A MOTIVE CALL
CALL PRESCN
CALL IFILE(22,'MODE2')
READ(22,2114)INP
CALL LULOOP
IREAD=-2
IDEV=-1
Z=STUP
CALL SETUP
C MUST RECALL SETUP BECAUSE SOME ARRAYS WERE USED IN PRESCN.(??)
STUP=Z
GO TO 6177
CC1001 REREAD 4177,RA,RB
CC CALL LO2UP(RA)
1001 CALL LULOOP
CALL A2READ(RA,RB)
IF(RA.NE.'SP')GO TO 5177
SET4=RB
C CAN SET SPACER HERE
GO TO 1177
5177 IF(INP1.EQ.IBLA) GO TO 1
IF(INP1.NE.N9)GO TO 80041
IF(INP2.EQ.N9)GO TO 99
C TYPE '99' TO BACK-UP
80041 IF(IREAD.LT.0)GO TO 6177
IF(IDEV.EQ.5)WRITE(21,2114)INP
6177 CALL LNEND
GO TO(333,433,533)MODE-2
C GO TO MARKZ, BEAMS, SLURZ
RETRO=-1.
I=1
PARENS=0
MOT=0
JZ=1
IAMP=0
C IAMP IS 'BLANK LINE'FLAG ON PP1-3.
KL=0
RA=0
IF(MODE.EQ.2)GO TO 2408
C NEXT CHECKS FOR STAFF NUM AT FRONT OF INPUT LINE#1.
IF(INP1.NE.LSS)GO TO 2408
IF(INP2.NE.LTT)GO TO 2408
K=1
L=3
IF(INP3.NE.MINUS)GO TO 1277
K=-1
L=4
1277 STAFF=NALF(INP(L))*K
2277 MLX=L+1
IF(INP(MLX).NE.KSLA)GO TO 2277
MLX=MLX+1
GO TO 3277
2408 MLX=1
3277 L=-1
CCCC IF(RMODE2.EQ.2)CALL PRESCN
C GO SORT OUT THE NEW FORMAT
DO 2999 K=1,72
N=INP(K)
IF(N.EQ.IBLA)GO TO 2999
L=0
IF(N.EQ.ISTAR)GO TO 277
IF(N.NE.ISEMI)GO TO 2999
C READS 72 CHARS. INCLUDING ;.
277 INP(K+1)=ISEMI
GO TO 1773
C --- X/Y/Z* --- WITH NO SEMICOLON WORKS FOR THIS PROG. ONLY!
2999 CONTINUE
IF(IREAD)GO TO 8015
CALL TYPSTR('****** TRY AGAIN ***** ')
CALL TYPCRLF
GO TO 1
1299 IF(JZ.NE.0)GO TO 1773
7773 IF(MODE.NE.2)GO TO 377
CCC IF(RMODE2.EQ.2)GO TO 77732
C ↑↑↑↑↑↑ FOR NEW INPUT FORMAT
377 IF(IREAD.EQ.0)GO TO 77731
C BYPASS IF NOT USING EDIT FILE
IF(IREAD.EQ.-1)READ(22,21141),L,INP
IF(IREAD.EQ.-2)READ(22,2114)INP
C TO READ 2ND LINE OF NOTE INPUT, IF NEEDED
CALL TYPOUT
CALL LULOOP
CC IF(IDEV.EQ.5)CALL TYPOUT
GO TO 77732
77731 CALL TYPE
IF(INP1.EQ.IBLA)GO TO 7773
IF(IDEV.EQ.5)WRITE(21,2114)INP
CALL LULOOP
77732 CALL LNEND
JM=-1
JZ=0
GO TO 2408
C 'LISTS' MUST END WITH ;
1773 JZ=0
DBST=1.
IF(XDBST)DBST=-DBST
XDBST=0
17731 ML=MLX
IF(PARENS.LE.0.)GO TO 975
C PARENS=-1, OPENS; =1, CLOSES; =0, NONE
3362 PARENS=0
MOT=I-LMOT
IF(LCNT+MOT.LT.198)GO TO 33621
CALL TYPSTR(' NO ROOM FOR MOTIVE ')
CALL TYPCHR(JMOT,1)
CALL TYPCRLF
GO TO 1
33621 JLIST(LCNT+1)=MOT
LCNT=LCNT+2
DO 2140 JG=0,MOT-1
2140 RLIST(LCNT+JG)=V(LMOT+JG)
LCNT=LCNT+MOT
IF(IAMP)GO TO 3013
C FOR CLOSE PARENS ON LAST ITEM
C STORE MOTIVE IN RLIST ARRAY
975 DO 236 JDD=ML,72
JD=JDD
N=INP(JD)
C ((((())))) MAY 13,71 /Z (D4/E/X 2 3/) CS/ ETC. CAN USE 26 LABELS.
IF(N.EQ.ILP)GO TO 477
IF(N.EQ.IRP)GO TO 477
IF(N.NE.ICOL)GO TO 2361
477 INP(JD)=IBLA
IF(N.NE.ICOL)GO TO 1113
XDBST=-1.
GO TO 5362
C GO CHANGE IT TO A SEMIC. !!! CAN'T END LINE WITH :
C SO NXT NOTE WILL BE DBST (TYPE /F:A:C/ ETC.)
C DBSTS WILL BE ONLY ONE 'REP' UNIT X*0Z%~#&@
1113 L=JD-1
5113 IF(INP(L).NE.IBLA)GO TO 2113
L=L-1
GO TO 5113
2113 IF(N.EQ.IRP)GO TO 3361
C ONLY ONE () AS YET, NO NESTING
1140 JMOT=INP(L)
C MOTIVE NAME
DO 11401 JC=1,LCNT-1
IF(JMOT.NE.JLIST(JC))GO TO 11401
C FINDS DUPLICATE IDENTIFIER
CALL TYPSTR(' MOTIVIC (')
CALL TYPCHR(JMOT,1)
CALL TYPSTR(') USED TWICE')
CALL TYPCRLF
JLIST(JC)=0
C ZERO OUT PREVIOUS USE OF IDENTIFIER.
11401 CONTINUE
JLIST(LCNT)=JMOT
PARENS=-1.
C A PARENTH IS OPEN
INP(L)=IBLA
LMOT=I
C LMOT IS CURRENT POINT IN V ARRAY
GO TO 236
3361 IF(PARENS.NE.0)GO TO 33612
CALL TYPSTR('PARENTH ERROR - GOING ON')
CALL TYPCRLF
33611 INP(JD)=IBLA
GO TO 236
33612 PARENS=1.
C SETS PARENS CLOSED FLAG
GO TO 33611
C NO INVERSIONS POSSIBLE NOW
2361 IF(N.NE.IAT)GO TO 5361
DO 113 L=1,72
K=JD+L
C K IS USED AT 240!!!
JG=INP(K)
IF(JG.NE.NEG)GO TO 7113
RETRO=0
INP(K)=IBLA
GO TO 113
7113 IF(JG.NE.IBLA)GO TO 4113
113 CONTINUE
4113 DO 6361 L=1,LCNT
IF(JG.NE.JLIST(L))GO TO 6361
VX1=0
DO 40 M=JD+2,72
JG=INP(M)
IF(JG.EQ.IBLA)GO TO 40
IF(JG.EQ.KSLA)GO TO 140
IF(JG.EQ.ISEMI)GO TO 140
IF(JG.EQ.ISTAR)GO TO 140
ML=M
GO TO 240
40 CONTINUE
240 JC=JM
JM=-1
INP(K)=IBLA
JN=0
C MUST BE ZERO IN SCANR
CALL SCANR
JM=JC
140 JC=1
KN=L+2
M=KN+JLIST(L+1)
IF(RETRO)GO TO 940
KN=M-1
M=L+1
JC=-1
RETRO=-1.
940 Z=RLIST(KN)
IF(VX1.EQ.0)GO TO 540
C " @Q N " WHERE N= DIATONIC STEPS IN 'NOTES' OR MULT FACTOR IN OTHERS.
IF(MODE.EQ.1)GO TO 440
C MODE 1 IS NOTES, 2 IS RHY.
V(I)=Z*VX1
GO TO 7361
440 IF(ABS(Z).GE.2000.)GO TO 540
C SKIPS NON-NOTES
RB=VX1
IF(Z)RB=-RB
C NOW TRANSPOSES BY DIAT. STEPS ONLY 100S=FLAT, 200S=SHARP, 300S=NAT
C NEG NUMS ARE CHORD NOTES.
V(I)=Z+RB
GO TO 7361
540 V(I)=Z
7361 I=I+1
KN=KN+JC
IF(KN.NE.M)GO TO 940
RB=V(I-1)
DO 8361 L=JD,72
JG=INP(L)
INP(L)=IBLA
IF(JG.EQ.KSLA)GO TO 9361
IF(JG.EQ.ISEMI)GO TO 93611
8361 IF(JG.EQ.ISTAR)IAMP=-1
9361 MLX=L
IF(IAMP.EQ.0)GO TO 17731
JZ=-1
93611 IF(IAMP)GO TO 3013
GO TO 7773
6361 CONTINUE
CALL TYPSTR(' MOTIVIC (')
CALL TYPCHR(JG,1)
CALL TYPSTR(') NOT FOUND')
CALL TYPCRLF
GO TO 11401
C @@@@@@@@@@@@@@@@@@@@@@@@@@
5361 IF(N.NE.KSLA)GO TO 636
5362 MLX=JD+1
JZ=-1
INP(JD)=ISEMI
436 IF(INP(MLX).NE.IBLA)GO TO 103
MLX=MLX+1
GO TO 436
636 IF(N.EQ.ISEMI)GO TO 103
936 IF(N.NE.IDOT)GO TO 736
L=INP(JD+1)
KL=NALF(L)
IF(L.LE.0)GO TO 577
IF(KL.LT.0)GO TO 577
IF(KL.LE.9)GO TO 236
C JUMP IF IT'S A NUMBER
577 IF(MODE.EQ.2)INP(JD)=1
C :::::::::******* ↑↑↑↑ MODE #?
GO TO 236
C CHANGES DOTTED RHYTHMS TO '1'S.
736 IF(N.NE.ISTAR)GO TO 236
IAMP=-1
INP(JD)=ISEMI
GO TO 103
236 CONTINUE
2114 FORMAT(72A1)
21141 FORMAT(I,72A1)
5016 IF(IAMP.GE.0)GO TO 1299
IF(PARENS.NE.0)GO TO 3362
C PARENS ARE STILL OPEN?
GO TO 3013
103 K=INP(ML)
C LAST SECTION
IF(K.EQ.ISEMI)GO TO 1014
C*********** MODE #?
IF(K.NE.IBLA) GO TO 1899
ML=ML+1
GO TO 103
1899 JN=0
C MUST BE ZERO IN SCANR
VX4=0
NOAC=0
CALL SCANR
IF(VX1.EQ.-99.)GO TO 4022
C NO MORE COMPOSITES IN RHYTH. DOTS ARE INDICATED BY 100S.
C RHYTH. NUMB IS KEPT HERE. DOTTED QUARTER IS NOW 104. DBL..=204
17 IF(MODE.NE.2)GO TO 117
IF(JJ.EQ.1)GO TO 117
IF(VX2.EQ.0)GO TO 117
C VX2=0 IF "X" IS USED. (8X3 FORMS VX1=8, VX2=0, VX3=3)
RB=0
DO 2117 K=1,JJ
2117 RB=RB+4./VX(K)
VX1=4./RB
C FOR COMPOSITE RHYTHMS. (USEFUL FOR 'WHOLE' RESTS IN 5/4, ETC.)
JJ=1
117 V(I)=VX1
IF(VX4.EQ.0)GO TO 115
IF(MODE.NE.1)GO TO 115
I=I+1
C FOR + OR -. AUTO OCTAVES, ETC.
V(I)=-VX1-VX4
115 IF(JJ.LE.1)GO TO 114
IF(MODE.NE.1)GO TO 171
IF(VX2.EQ.0)GO TO 171
C JUMP IF RHY OR 'X 4' ETC.
V(I)=18000.0+VX1*10.0+VX2/10.0
C PACKS 2 METER NUMS INTO ONE SLOT (18xyz.n xy=top, zn=bottom)
114 I=I+1
GO TO 5016
171 JC=1
JD=VX(JJ)-1
I=I+1
GO TO 5005
1014 JD=1
JC=1
C X4/ CREATES REP 1,4; A/// CREATES REP 1,3;
GO TO 5005
4022 JC=VX2+.3
JD=VX3-.5
IF(MODE.EQ.1)NOAC=-1
C ACCIS WILL NOT!! REPEAT UNLESS 100 IS ADDED TO 1ST NUM.******6/78
IF(JJ.EQ.2)JD=1
C JD=HOW MANY TIMES, JC=HOW MANY NOTES
IF(JC.LT.100)GO TO 5005
C ADD 100 TO NUM OF NOTES TO REPEAT ACCIS WITH 'REP N1, N2'.
JC=JC-100
NOAC=0
5005 N=0
DO 3005 K=I-1,1,-1
IF(V(K))GO TO 3005
IF(V(K).LT.3000)N=N+1
C COUNTS RESTS AND NOTES ONLY (NO CHORD NOTES)
3005 IF(N.EQ.JC)GO TO 4005
4005 IF(JC.GT.1)GO TO 7005
IF(MODE.EQ.1)NOAC=-1
C 5/76 ******* AF/// WILL CREATE AF/A//-- AN:FS/// = AN:FS/A:F// *******
C ACCIS ARE DROPPED WITH / OR Xn REPEAT. (BUT NOT WITH 'REP' OR '/X n,n/')
7005 JC=I-K
C ALL THIS IS TO FIND COMPLETE CHORDS, BARS, ETC. TO REPEAT.
C REPS WILL ONLY COUNT RHYTHMIC UNITS.!
DO 1005 K=1,JD
NL=I+JC-1
DO 2005 L=I,NL
KN=L-JC
RB=V(KN)
IF(NOAC.GE.0)GO TO 2005
IF(ABS(RB).GE.2000)GO TO 2005
C SKIP OVER IF NOT A NOTE
RB=AMOD(RB,100.0)+1000.0
IF(V(KN))RB=RB-2000.0
C DROPS ACCIS WHEN SLASH REP. OR 'X' IS USED.
2005 V(L)=RB
1005 I=I+JC
GO TO 5016
3013 IF(MODE.NE.2)GO TO 771
IF(I-1.NE.IRHY)GO TO 8015
C WRONG NUMBER OF ITEMS
771 V(I)=-99.
IF(MODE.NE.1)GO TO 132
C FOR ADDED NOTES ON SPACING STAFF
CALL NOTES
C SAVES TOTAL OF ITEMS FOR LABEL 168
67 CALL NEWR
IX=IS
C SAVE PTR TO RN ARRAY FOR TREM. OVER BEAM LATER. (IN 'BEAMS.F4')
GO TO 8006
132 IF(IREAD.GT.0)IREAD=-IREAD
CALL RHYTH
C =50 IS RHYTHM FOR TEXT
GO TO 67
134 IF(IDEV.EQ.5)WRITE(21,2114)INP
C WRITES TYPED IN REPLY TO 'ADD BEAMS?'
C ACCENTS ARE IN MARKZ SUBROUTINE
GO TO 8006
533 CALL SLURZ
GO TO 8006
433 CALL BEAMS
C ADJUSTS STEMS (IBEAM=0) IF BEAMS WERE ENTERED.
IBEAM=0
GO TO 8006
333 CALL MARKZ
135 K=IS
CALL NEWR
IS=K
C ↑↑↑↑↑↑ TO ADD NEW ITEMS, SUCH AS PPP, MP, CRESC., ETC.(SEE 'MARKS')
GO TO 8006
END
SUBROUTINE A2READ(A,B)
REREAD 1,A,B
CALL LO2UP(A)
1 FORMAT(A2,F)
END